home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue39 / ComCorn / CliMain.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-10-06  |  4.3 KB  |  178 lines
  1. unit CliMain;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, Server_TLB, ComObj;
  8.  
  9. type
  10.   TEventSink = class;
  11.  
  12.   TMainForm = class(TForm)
  13.     SendButton: TButton;
  14.     CloseButton: TButton;
  15.     ClearButton: TButton;
  16.     Edit: TEdit;
  17.     Memo: TMemo;
  18.     procedure FormCreate(Sender: TObject);
  19.     procedure SendButtonClick(Sender: TObject);
  20.     procedure ClearButtonClick(Sender: TObject);
  21.     procedure CloseButtonClick(Sender: TObject);
  22.     procedure FormDestroy(Sender: TObject);
  23.   private
  24.     { Private declarations }
  25.     FServer: IServerWithEvents;
  26.     FEventSink: TEventSink;
  27.     FCookie: Integer;
  28.     procedure OnServerMemoChanged(const NewText: string);
  29.     procedure OnClear;
  30.   public
  31.     { Public declarations }
  32.   end;
  33.  
  34.   TEventSink = class(TObject, IUnknown, IDispatch)
  35.   private
  36.     FController: TMainForm;
  37.     { IUnknown }
  38.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  39.     function _AddRef: Integer; stdcall;
  40.     function _Release: Integer; stdcall;
  41.     { IDispatch }
  42.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  43.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  44.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  45.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  46.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  47.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  48.   public
  49.     constructor Create(Controller: TMainForm);
  50.   end;
  51.  
  52. var
  53.   MainForm: TMainForm;
  54.  
  55. implementation
  56.  
  57. uses ActiveX;
  58.  
  59. {$R *.DFM}
  60.  
  61. { TMainForm }
  62.  
  63. procedure TMainForm.FormCreate(Sender: TObject);
  64. begin
  65.   FServer := CoServerWithEvents.Create;
  66.   FEventSink := TEventSink.Create(Self);
  67.   InterfaceConnect(FServer, IServerWithEventsEvents, FEventSink, FCookie);
  68. end;
  69.  
  70. procedure TMainForm.FormDestroy(Sender: TObject);
  71. begin
  72.   InterfaceDisconnect(FEventSink, IServerWithEventsEvents, FCookie);
  73.   FEventSink.Free;
  74. end;
  75.  
  76. procedure TMainForm.SendButtonClick(Sender: TObject);
  77. begin
  78.   FServer.AddText(Edit.Text);
  79. end;
  80.  
  81. procedure TMainForm.ClearButtonClick(Sender: TObject);
  82. begin
  83.   FServer.Clear;
  84. end;
  85.  
  86. procedure TMainForm.CloseButtonClick(Sender: TObject);
  87. begin
  88.   Close;
  89. end;
  90.  
  91. procedure TMainForm.OnServerMemoChanged(const NewText: string);
  92. begin
  93.   Memo.Text := NewText;
  94. end;
  95.  
  96. procedure TMainForm.OnClear;
  97. begin
  98.   Memo.Clear;
  99. end;
  100.  
  101. { TEventSink }
  102.  
  103. constructor TEventSink.Create(Controller: TMainForm);
  104. begin
  105.   FController := Controller;
  106.   inherited Create;
  107. end;
  108.  
  109. { TEventSink.IUnknown }
  110.  
  111. function TEventSink._AddRef: Integer;
  112. begin
  113.   // No need to implement, since lifetime is tied to client
  114.   Result := 1;
  115. end;
  116.  
  117. function TEventSink._Release: Integer;
  118. begin
  119.   // No need to implement, since lifetime is tied to client
  120.   Result := 1;
  121. end;
  122.  
  123. function TEventSink.QueryInterface(const IID: TGUID; out Obj): HResult;
  124. begin
  125.   // First look for my own implementation of an interface
  126.   // (I implement IUnknown and IDispatch).
  127.   if GetInterface(IID, Obj) then
  128.     Result := S_OK
  129.   // Next, if they are looking for outgoing interface, recurse to return
  130.   // our IDispatch pointer.
  131.   else if IsEqualIID(IID, IServerWithEventsEvents) then
  132.     Result := QueryInterface(IDispatch, Obj)
  133.   // For everything else, return an error.
  134.   else
  135.     Result := E_NOINTERFACE;
  136. end;
  137.  
  138. { TEventSink.IDispatch }
  139.  
  140. function TEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  141.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  142. begin
  143.   Result := E_NOTIMPL;
  144. end;
  145.  
  146. function TEventSink.GetTypeInfo(Index, LocaleID: Integer;
  147.   out TypeInfo): HResult;
  148. begin
  149.   Pointer(TypeInfo) := nil;
  150.   Result := E_NOTIMPL;
  151. end;
  152.  
  153. function TEventSink.GetTypeInfoCount(out Count: Integer): HResult;
  154. begin
  155.   Count := 0;
  156.   Result := S_OK;
  157. end;
  158.  
  159. function TEventSink.Invoke(DispID: Integer; const IID: TGUID;
  160.   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  161.   ArgErr: Pointer): HResult;
  162. var
  163.   V: OleVariant;
  164. begin
  165.   Result := S_OK;
  166.   case DispID of
  167.     1:
  168.       begin
  169.         // First parameter is new string
  170.         V := OleVariant(TDispParams(Params).rgvarg^[0]);
  171.         FController.OnServerMemoChanged(V);
  172.       end;
  173.     2: FController.OnClear;
  174.   end;
  175. end;
  176.  
  177. end.
  178.